home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.02 Feb 87 / forth source / Mach2 DA.fth next >
Encoding:
Text File  |  1986-12-07  |  10.9 KB  |  514 lines  |  [TEXT/MACA]
  1. ( trying to build a desk accessory in Mach2, J. Langowski Oct. 86 )
  2.  
  3. only forth also assembler also mac
  4.  
  5. HEX
  6. 44525652 CONSTANT "drvr
  7.  
  8. BINARY
  9. 0000110111101010 CONSTANT DAEmask
  10.  
  11. ( *** System globals *** )
  12. HEX
  13. 8FC CONSTANT JioDone 
  14.  
  15. DECIMAL
  16. ( windowrecord fields, starting with grafport )
  17. 16 CONSTANT    portRect    ( Grafport rectangle )
  18.  
  19. ( fields of WindowPeek )
  20. 108 CONSTANT windowKind 
  21. 110 CONSTANT wVisible
  22. 111 CONSTANT wHiLited    
  23. 112 CONSTANT goAwayFlag
  24. 113 CONSTANT spareFlag
  25. 130 CONSTANT dataHandle
  26. 140 CONSTANT controlList
  27. 152 CONSTANT refCon
  28.  
  29. ( fields of device control entry )
  30.  4 CONSTANT dCtlFlags
  31.  6 CONSTANT dCtlQHdr
  32. 16 CONSTANT dCtlPosition
  33. 20 CONSTANT dCtlStorage
  34. 24 CONSTANT dCtlRefNum
  35. 26 CONSTANT dCtlCurTicks
  36. 30 CONSTANT dCtlWindow
  37. 34 CONSTANT dCtlDelay
  38. 36 CONSTANT dCtlEMask
  39. 38 CONSTANT dCtlMenu
  40.  
  41. ( csCodes for Ctl calls )
  42. -1 CONSTANT goodBye
  43. 64 CONSTANT accEvent
  44. 65 CONSTANT accRun
  45. 66 CONSTANT accCursor
  46. 67 CONSTANT accMenu
  47. 68 CONSTANT accUndo
  48. 70 CONSTANT accCut
  49. 71 CONSTANT accCopy
  50. 72 CONSTANT accPaste
  51. 73 CONSTANT accClear
  52.  
  53. ( *** standard parameter block data structure *** )
  54. 0   CONSTANT  qLink        ( pointer to next queue entry [long word] )
  55. 4   CONSTANT  qType        ( queue type [word] )
  56. 6   CONSTANT  ioTrap        ( routine trap [word] )
  57. 8   CONSTANT  ioCmdAddr        ( routine address [long word] )
  58. 12  CONSTANT  ioCompletion    ( addr of completion routine [long word] )
  59. 16  CONSTANT  ioResult        ( result code returned here [word] )
  60. 18  CONSTANT  ioNamePtr        ( pointer to file name string [long word] )
  61. 22  CONSTANT  ioVRefNum        ( volume reference number )
  62. 24  CONSTANT  ioRefNum
  63. 26  CONSTANT  csCode        ( type of control call )
  64. 28  CONSTANT  csParam        ( control call parameters )
  65.  
  66. ( *** eventrecord data structure *** )
  67. 0  CONSTANT what
  68. 2  CONSTANT message
  69. 6  CONSTANT when
  70. 10 CONSTANT where
  71. 14 CONSTANT modifiers
  72.  
  73. ( *** event codes *** )
  74. 0  CONSTANT null-evt
  75. 1  CONSTANT mousedn-evt
  76. 2  CONSTANT mouseup-evt
  77. 3  CONSTANT keydn-evt
  78. 4  CONSTANT keyup-evt
  79. 5  CONSTANT autokey-evt
  80. 6  CONSTANT update-evt
  81. 7  CONSTANT disk-evt
  82. 8  CONSTANT activate-evt
  83. 10 CONSTANT network-evt
  84. 11 CONSTANT driver-evt
  85.  
  86. CODE shl ( data #bits )
  87.     MOVE.L (A6)+,D0
  88.     MOVE.L (A6),D1
  89.     LSL.L  D0,D1
  90.     MOVE.L D1,(A6)
  91.     RTS
  92. END-CODE    MACH
  93.  
  94. CODE shr ( data #bits )
  95.     MOVE.L (A6)+,D0
  96.     MOVE.L (A6),D1
  97.     LSR.L  D0,D1
  98.     MOVE.L D1,(A6)
  99.     RTS
  100. END-CODE    MACH
  101.  
  102.  
  103. ( *** start of desk accessory main code *** )
  104.  
  105. header testDA ( marker for writing to DRVR resource )
  106.     header drvrFlags  2 allot
  107.     header drvrdelay  2 allot
  108.     header drvrEMask  2 allot 
  109.     header drvrMenu   2 allot
  110.     header drvrOpen   2 allot
  111.     header drvrPrime  2 allot
  112.     header drvrCtl     2 allot
  113.     header drvrStatus    2 allot 
  114.     header drvrClose  2 allot
  115.     header drvrname  32 allot
  116.  
  117. ( *** main desk accessory routines *** )
  118. header oldPort 4 allot        ( for storage of old grafPtr )
  119. header temprect 8 allot
  120. header SizeRect 8 allot     ( grow size limits )
  121. header mouseLoc 4 allot        ( mouse location )
  122. header NewSize 4 allot        ( for SizeWindow )
  123. header penLoc 4 allot        ( pen location )
  124. header tempString 256 allot   ( for numeric conversion etc. )
  125. header zoomState 4 allot    ( zoomed in or out )
  126.  
  127. : whereMouse ['] mouseLoc call getMouse ['] mouseLoc @ ;
  128.  
  129. : cl    ( WPtr -- ) portrect + call eraserect ;
  130.  
  131. : tp  call drawstring ;
  132.  
  133. : crd ['] penLoc call getpen
  134.     10 ( horizontal boundary )
  135.     ['] penLoc w@ 12 +
  136.     call moveto
  137. ;
  138.  
  139. CODE NumToString
  140.     MOVE.L (A6)+,A0
  141.     MOVE.L (A6),D0
  142.     MOVE.W #0,-(A7)
  143.     _Pack7
  144.     MOVE.L A0,(A6)
  145.     RTS
  146. END-CODE
  147.  
  148. CODE StringToNum
  149.     MOVE.L (A6),A0
  150.     MOVE.W #1,-(A7)
  151.     _Pack7
  152.     MOVE.L D0,(A6)
  153.     RTS
  154. END-CODE
  155.  
  156. CODE unpack
  157.     MOVE.L (A6),D0
  158.     CLR.L     D1
  159.     MOVE.W D0,D1
  160.     CLR.W  D0
  161.     SWAP.W D0
  162.     MOVE.L D0,(A6)
  163.     MOVE.L D1,-(A6)
  164.     RTS
  165. END-CODE
  166.  
  167. CODE pack
  168.     MOVE.L (A6)+,D1
  169.     MOVE.L (A6),D0
  170.     SWAP.W D0
  171.     MOVE.W D1,D0
  172.     MOVE.L D0,(A6)
  173.     RTS
  174. END-CODE
  175.  
  176. : .d ( num -- )
  177.     ['] tempstring NumToString
  178.     tp
  179. ;
  180.     
  181. ( *** event-handling routines *** )
  182.  
  183. : activate-handler { menuID DAWind event-rec | -- }
  184.         event-rec modifiers + w@ 1 and
  185.         IF ( window activated )
  186.         menuID call getRMenu 0 call InsertMenu  
  187.         call drawMenuBar
  188.         ELSE ( window deactivated )
  189.         menuID call deleteMenu
  190.         menuID call getRMenu call DisposMenu
  191.         call drawMenuBar
  192.         THEN
  193. ;
  194.  
  195.     
  196. : update-handler    { DAWind event-rec | -- }
  197.     ['] penLoc call GetPen
  198.     DAWind CALL BeginUpdate
  199.        DAWind cl
  200.        DAWind CALL DrawGrowIcon
  201.     DAWind CALL EndUpdate
  202.     ['] penLoc 2+ w@ ['] penLoc w@ call moveto ( restore pen position )
  203. ;
  204.  
  205. : ?inGrow { localPt WPtr | b r -- flag }
  206.      WPtr portRect + 4 +
  207.     dup w@ -> b 2+ w@ -> r
  208.     ['] temprect r 14 - b 14 - r b call setrect
  209.     localPt ['] tempRect call PtInRect 
  210. ;
  211.  
  212. : ?inZoom { localPt WPtr | r -- flag }
  213.      WPtr portRect + 6 + w@ -> r
  214.     ['] temprect r 20 - -16 r 8 - -4 call setrect
  215.     localPt ['] tempRect call PtInRect 
  216. ;
  217.  
  218. : invalSize { gPort | b r -- }
  219.     gPort 4 + w@ -> b
  220.     gPort 6 + w@ -> r
  221.     ['] temprect r 16 - 0 r b call setrect
  222.     ['] temprect call invalrect
  223.     ['] temprect 0 b 16 - r b call setrect
  224.     ['] temprect call invalrect
  225. ;
  226.  
  227. : mousedn-handler { DAWind event-rec | whereM DAPort -- }
  228.     DAWind portrect + -> DAPort
  229.     event-rec where + @ -> whereM
  230.     whereM ['] mouseLoc !
  231.     ['] mouseloc call GlobalToLocal
  232.     ['] mouseloc @ dup 
  233.     DAWind ?inGrow  
  234.     IF    DAPort invalSize
  235.         DAWind whereM ['] SizeRect call GrowWindow 
  236.         DAWind swap unpack swap -1 call sizewindow
  237.         DAPort invalSize
  238.     ELSE 
  239.       DAWind ?inZoom
  240.       IF     ['] zoomState @
  241.         IF 0 ['] zoomState !
  242.            DAWind whereM 7 call TrackBox
  243.             IF DAPort invalSize
  244.                DAWind 7 0 call ZoomWindow THEN
  245.         ELSE 1 ['] zoomState !        
  246.            DAWind whereM 8 call TrackBox
  247.             IF DAWind 8 0 call ZoomWindow 
  248.                DAPort invalSize THEN
  249.         THEN
  250.       ELSE ( in content region )
  251.         " Mouse down" tp crd
  252.       THEN
  253.     THEN
  254. ;
  255.  
  256. : update-cursor    { DAWind | -- }
  257.     whereMouse    DAWind portrect + call PtInRect
  258.     IF call InitCursor THEN
  259. ;
  260.  
  261. : getDrvrID { dCtlEntry | -- num }
  262.     dCtlEntry dCtlRefNum + w@ l_ext
  263.     1+ negate
  264. ;
  265.  
  266. : ownResID ( resID drvrID )
  267.     5 shl + -16384 +
  268. ;
  269.  
  270. : Open { DCtlEntry ParamBlockRec | DAWind -- }
  271.     ['] oldPort call GetPort
  272.     dCtlEntry dCtlWindow + @
  273.     0= IF ( not open already )
  274.         0 dCtlEntry getDrvrID ownResID 
  275.         dup dCtlEntry DCtlMenu + w! 
  276.             ( menu ref has to be updated )
  277.         0 0 call getNewWindow -> DAWind
  278.         DAWind  dCtlEntry dCtlWindow + !  ( store window pointer )
  279.         DAWind  dCtlEntry dCtlRefNum + w@  swap windowKind + w!
  280.         DAWind  call setport
  281.         0 ['] zoomState !
  282.         ['] sizerect 50 50 500 320 call setrect
  283.         10 10   call moveto
  284.         ['] oldPort @ call setPort
  285.     THEN
  286. ;
  287.  
  288. : Close { DCtlEntry ParamBlockRec | -- }
  289.     dCtlEntry dCtlWindow + 
  290.     dup @ call DisposWindow  0 swap ! ( so that Open will work again )
  291.     DCtlEntry DCtlMenu + w@ ( get menu ID )
  292.     dup call deletemenu
  293.     call getRMenu call disposMenu call drawMenuBar
  294. ;
  295.  
  296. : Ctl { DCtlEntry ParamBlockRec | DAWind event-rec menuItem -- }
  297.  
  298.     ['] oldPort call GetPort
  299.     dCtlEntry dCtlWindow + @ dup -> DAWind call setport
  300.     ParamBlockRec csCode + w@ l_ext 
  301.     CASE
  302.         goodBye    OF 50 call sysbeep ENDOF
  303.         accEvent    OF 
  304.                 ParamBlockRec csParam + @ -> event-rec
  305.                 event-rec what + w@ 
  306.                 CASE
  307.                 mousedn-evt    OF     
  308.                     DAWind event-rec mousedn-handler  ENDOF
  309.  
  310.                 keydn-evt    OF DAWind cl
  311.                         DAWind call DrawGrowIcon
  312.                         10 10 call moveto " Key down." tp crd
  313.                         ENDOF
  314.  
  315.                 autokey-evt    OF    ENDOF
  316.  
  317.                 update-evt    OF
  318.                  DAWind event-rec update-handler     ENDOF
  319.  
  320.                 disk-evt    OF    ENDOF
  321.  
  322.                 activate-evt    OF
  323.                  DCtlEntry DCtlMenu + w@ ( get menu ID )
  324.                  DAWind event-rec activate-handler  ENDOF
  325.  
  326.                 network-evt    OF    ENDOF
  327.                 driver-evt    OF    ENDOF
  328.  
  329.                 ENDCASE
  330.  
  331.                 ENDOF
  332.  
  333.         accRun    OF    1 call sysbeep     ENDOF
  334.         accCursor    OF    DAWind update-cursor    ENDOF
  335.         accMenu    OF    ParamBlockRec csParam + 2+ w@ l_ext
  336.                     CASE     1 OF " Item1!" tp crd ENDOF
  337.                         2 OF " Item2!" tp crd ENDOF
  338.                         3 OF " Item3!" tp crd ENDOF
  339.                         4 OF " Item4!" tp crd ENDOF
  340.                         6 OF " Item6!" tp crd ENDOF
  341.                     ENDCASE
  342.                     0 call HiLiteMenu
  343.                 ENDOF
  344.         accUndo    OF    ENDOF
  345.         accCut    OF    ENDOF
  346.         accCopy    OF    ENDOF
  347.         accPaste    OF    ENDOF
  348.         accClear    OF    ENDOF
  349.     ENDCASE
  350.     ['] oldPort @ call setPort
  351. ;
  352.  
  353.  
  354. : DrStatus { DCtlEntry ParamBlockRec | -- }
  355. ;
  356.  
  357. : Prime { DCtlEntry ParamBlockRec | -- }
  358. ;
  359.  
  360. ( *** glue routines *** )
  361. header local.stack 200 allot
  362.  
  363. CODE setup.local.stack
  364.     LEA -8(PC),A6   ( local stack grows downward from here )
  365.     RTS
  366. END-CODE
  367.  
  368. CODE DAOpen 
  369.     MOVEM.L A0-A1,-(A7)
  370.     setup.local.stack
  371.     MOVE.L  A1,-(A6) 
  372.     MOVE.L  A0,-(A6)
  373.     Open
  374.     CLR.L  D0
  375.     MOVEM.L (A7)+,A0-A1 
  376. RTS END-CODE
  377.  
  378. CODE DAClose  
  379.     MOVEM.L A0-A1,-(A7)
  380.     setup.local.stack
  381.     MOVE.L  A1,-(A6) 
  382.     MOVE.L  A0,-(A6)
  383.     Close
  384.     CLR.L   D0
  385.     MOVEM.L (A7)+,A0-A1 
  386. RTS END-CODE
  387.  
  388. CODE DACtl 
  389.     MOVEM.L A0-A1,-(A7)
  390.     setup.local.stack
  391.     MOVE.L  A1,-(A6) 
  392.     MOVE.L  A0,-(A6)
  393.     Ctl
  394.     CLR.L   D0
  395.     MOVEM.L (A7)+,A0-A1
  396.     MOVE.L  JioDone,-(A7) 
  397. RTS END-CODE
  398.  
  399. CODE DAStatus 
  400.     MOVEM.L A0-A1,-(A7)
  401.     setup.local.stack
  402.     MOVE.L  A1,-(A6) 
  403.     MOVE.L  A0,-(A6)
  404.     DrStatus
  405.     CLR.L   D0
  406.     MOVEM.L (A7)+,A0-A1 
  407. RTS END-CODE
  408.  
  409. CODE DAPrime 
  410.     MOVEM.L A0-A1,-(A7)
  411.     setup.local.stack
  412.     MOVE.L  A1,-(A6) 
  413.     MOVE.L  A0,-(A6)
  414.     Prime
  415.     CLR.L   D0
  416.     MOVEM.L (A7)+,A0-A1 
  417. RTS END-CODE
  418.  
  419. header endDA ( *** code written to DRVR resource ends here *** )
  420.  
  421. ( *** initialization routines *** ) 
  422.  
  423. : setFlags  ['] drvrFlags     w! ;
  424. : setDelay     ['] drvrDelay    w! ;
  425. : setEMask     ['] drvrEMask    w! ;
  426. : setMenuID    ['] drvrMenu    w! ;
  427.  
  428. : setOpen    ['] drvrOpen    w! ;
  429. : setPrime    ['] drvrPrime    w! ;
  430. : setCtl    ['] drvrCtl        w! ;
  431. : setStatus    ['] drvrStatus    w! ;
  432. : setClose    ['] drvrClose    w! ;
  433.  
  434. : setName { addr len | target -- }
  435.     ['] drvrName -> target
  436.     len target c!
  437.     addr target 1+
  438.     len 31 > if  31 else len then
  439.     cmove
  440. ;
  441.  
  442.  
  443. ( write resource to file ) 
  444. : $create-res ( str-addr - errcode )
  445.     call CreateResFile
  446.     call ResError L_ext
  447. ;
  448.  
  449. : $open-res { addr | refNum - refNum or errcode }
  450.     addr call OpenResFile -> refNum
  451.     call ResError L_ext
  452.     ?dup IF ELSE refNum THEN
  453. ; 
  454.  
  455. : close-res ( refNum - errcode )
  456.     call CloseResFile
  457.     call ResError L_ext
  458. ;
  459.  
  460. : make-res { addr len rtype ID name | -- }
  461.     addr len call PtrToHand 
  462.     abort" Could not create resource handle"
  463.     rtype ID name call AddResource
  464. ;
  465.  
  466. : write-out { filename | refnum -- } 
  467.     filename $create-res abort" That resource file already exists"
  468.     filename $open-res
  469.     dup 0< abort" Open resource file failed"
  470.     -> refnum
  471.     refnum call UseResFile
  472.     ['] testDA ['] endDA over - 
  473.         "drvr 12 " Mach 2 DA" make-res
  474.     refnum close-res abort" Could not close resource file"
  475. ;
  476.  
  477. : install-system { | refnum -- }
  478.     " System" $open-res
  479.     dup 0< abort" Open resource file failed"
  480.     -> refnum
  481.     refnum call UseResFile
  482.     "drvr 25 call getresource call rmveresource
  483.     ['] testDA ['] endDA over - 
  484.         "drvr 25 " Mach 2 DA" make-res
  485.     refnum call UpdateResFile    
  486. ;
  487.  
  488. : init-DA
  489. ( initialize offsets )
  490.     ['] DAOpen     ['] testDA -  setOpen 
  491.     ['] DAPrime  ['] testDA -  setPrime
  492.     ['] DACtl    ['] testDA -  setCtl 
  493.     ['] DAStatus ['] testDA -  setStatus
  494.     ['] DAClose  ['] testDA -  setClose
  495. ( initialize driver name )
  496.     " Mach 2 DA" count setname
  497. ( initialize driver flags, NeedTime, NeedGoodBye, CtlEnable )
  498.     [ hex ] 3400 setFlags [ decimal ]
  499. ( initialize delay time )
  500.     60 setDelay
  501. ( initialize event mask, events recommended in IM )
  502.     DAEMask setEMask 
  503. ( initialize menu ID, local ID=0 for DRVR ID=12 )
  504.     -16000 setMenuID ( careful! this field will NOT be changed
  505.                 by the DA Mover when ID is changed )
  506. ;
  507.     
  508. : make-DA
  509.     init-DA
  510.     " Mach2 DA.rsrc" write-out
  511. ;
  512.  
  513. : install-DA init-DA install-system bye ;
  514.